/* Core */

: call (xt: x --) {
  R1S(*IP++);
  PUSH(RP, IP);
  IP_SET(R1);
}

: return (--) {
  IP_SET(POP(RP));
}

: bye (--) {
  goto bye;
}

: docon (-- n) {
  PUSH(SP, *A(IP + CELL_SIZE));
}

: dolit (x -- xt:x & xt: x --) {
  PUSH(SP, *IP++);
}

: execute (xt --) {
  PUSH(RP, IP);
  IP_SET(POP(SP));
}

: atexec (a -- ) {
  PUSH(RP, IP);
  R1S(POP(SP));
  JUMP(*A(R1));
}

: branch (xt: xt --) {
  IP_SET(*IP);
}

: 0branch (n -- & xt: xt --) {
  if (POP(SP)) {
    IP_INC(1);
  } else {
    IP_SET(*IP);
  }
}

: @ (a -- x) {
  TOS_SET(*A(TOS));
}

: c@ (ca -- x) {
  TOS_SET(*CA(TOS));
}

: ! (x a --) {
  R1S(POP(SP));
  R2S(POP(SP));
  *A(R1) = R2;
}

: +! (n a --) {
  R1S(POP(SP));
  R2S(POP(SP));
  *A(R1) += R2;
}

: c! (c ca --) {
  R1S(POP(SP));
  R2S(POP(SP));
  *CA(R1) = (char)R2;
}

: on (a --) {
  R1S(POP(SP));
  *A(R1) = TRUE;
}

: off (a --) {
  R1S(POP(SP));
  *A(R1) = FALSE;
}

: >r (x -- & r: -- x) {
  PUSH(RP, POP(SP));
}

: r>  (-- r:x & r: x --) {
  PUSH(SP, POP(RP));
}

: r@ (-- x & r: x -- x) {
  PUSH(SP, *RP);
}

: rdrop  (r: x --) {
  DROP(RP);
}

: dup (x -- x x) {
  DUP(SP);
}

: ddup (x -- x x x) {
  DUP(SP);
  DUP(SP);
}

: 2dup (x 1 -- x x1 x x1) {
  PUSH(SP, S(1));
  PUSH(SP, S(1));
}

: ?dup (x -- x x | 0) {
  if (TOS) {
    DUP(SP);
  } else {
    TOS_SET(0);
  }
}

: drop (x --) {
  DROP(SP);
}

: 2drop (x x1 --) {
  SP = SP + 2;
}

: swap (x x1 -- x1 x) {
  R1S(S(0));
  TOS = S(1);
  S(1) = R1;
}

: 2swap (a b c d -- c d a b) {
  R1S(S(0));
  S(0) = S(2);
  S(2) = R1;
  R1S(S(1));
  S(1) = S(3);
  S(3) = R1;
}

: nip (x x1 -- x1) {
  R1S(POP(SP));
  TOS = R1;
}

: over (x x1 -- x x1 x) {
  PUSH(SP, S(1));
}

: tuck (a b -- b a b) {
  PUSH(SP, TOS);
  S(1) = S(2);
  S(2) = TOS;
}

: pick (a -- b) {
  TOS = S(TOS);
}

: rot (a b c -- b c a) {
  R1S(S(0));
  S(0) = S(2);
  S(2) = S(1);
  S(1) = R1;
}

: -rot (a b c -- c a b) {
  R1S(S(0));
  S(0) = S(1);
  S(1) = S(2);
  S(2) = R1;
}

#define EXP_INST(x) R1S(POP(SP)); TOS = TOS x R1

: + (n1 n2 -- n3) {
  EXP_INST(+);
}

: - (n1 n2 -- n3) {
  EXP_INST(-);
}

: * (n1 n2 -- n3) {
  EXP_INST(*);
}

: / (n1 n2 -- n3) {
  EXP_INST(/);
}

: mod (n1 n2 -- n3) {
  EXP_INST(%);
}

: abs (n -- u) {
  R1S(POP(SP));
  TOS_SET(R1 < 0 ? -R1 : R1);
}

: lshift (n1 n2 -- n3) {
  EXP_INST(<<);
}

: rshift (n1 n2 -- n3) {
  EXP_INST(>>);
}

: not (f -- f1) {
  PUSH(SP, NOT(TOS));
}

: and (n1 n2 -- n3) {
  EXP_INST(&);
}

: or (n1 n2 -- n3) {
  EXP_INST(|);
}

: xor (n1 n2 -- n3) {
  EXP_INST(^);
}

: invert (n1 n2 -- n3) {
  EXP_INST(^);
}

#define EQ_INST(x) TOS = (TOS == x)

: = (x x1 -- f) {
  EXP_INST(==);
}

: <> (a b -- f) {
  EXP_INST(!=);
}

: < (a b -- f) {
  EXP_INST(<);
}

: > (a b -- f) {
  EXP_INST(>);
}

: >= (a b -- f) {
  EXP_INST(>=);
}

: <= (a b -- f) {
  EXP_INST(<=);
}

: 0= (n -- f) {
  EQ_INST(0);
}

: 0< (n -- f) {
  TOS_SET(TOS < 0);
}

: 1+ (n -- n1) {
  TOS_SET(TOS + 1);
}

: 1- (n -- n1) {
  TOS_SET(TOS - 1);
}

: 0 (-- 0) {
  PUSH(SP, 0);
}

: 1 (-- 1) {
  PUSH(SP, 1);
}

: -1 (-- 1) {
  PUSH(SP, -1);
}

: true (-- true) {
  PUSH(SP, TRUE);
}

: false (-- true) {
  PUSH(SP, FALSE);
}

: $cell (-- n) {
  PUSH(SP, CELL_SIZE);
}

#define T cell

: ccall0->0 (xt: a / - ) {
  FUN_CALL(void, *IP++, ());
}

: ccall1->0 (xt: a / x - ) {
  FUN_CALL(void, *IP++, (T), POP(SP));
}

: ccall2->0 (xt: a / x x1 - ) {
  R1S(POP(SP));
  FUN_CALL(void, *IP++, (T, T), R1, POP(SP));
}

: ccall3->0 (xt: a / x x1 - ) {
  R1S(POP(SP));
  R2S(POP(SP));
  FUN_CALL(void, *IP++, (T, T, T), R1, R2, POP(SP));
}

: ccall0->1 (xt: a / - x) {
  TOS_SET(FUN_CALL(T, *IP++, ()));
}

: ccall1->1 (xt: a / x - x1) {
  TOS_SET(FUN_CALL(T, *IP++, (T), TOS));
}

: ccall2->1 (xt: a / x x1 - x2) {
  R1S(POP(SP));
  TOS_SET(FUN_CALL(T, *IP++, (T, T), R1, TOS));
}

: ccall3->1 (xt: a / x x1 x2 - x3) {
  R1S(POP(SP));
  R2S(POP(SP));
  TOS_SET(FUN_CALL(T, *IP++, (T, T, T), R1, R2, TOS));
}

/* Exception */

cell *cb = NULL;

: throw (n --) {
  throw:
  if (cb) {
    $call(pop, cb);
    IP_SET(POP(SP));
  } else {
    printf("error[%d]: %s\n", (int)TOS, EXCEPTION_MESSAGE(TOS));
    DROP(SP);
  }
}

/* Engine */

: engine ( - a) {
  PUSH(SP, E);
}

/* Image */

: allot (n - a) {
  R1S(HERE);
  HERE_INC(TOS);
  TOS_SET(R1);
}

: header (name - xt) {
  $call(intern);
  HERE_INC(XT_HEADER_SIZE);
  cell *xt = HERE;
  XT_VAL(xt, NAME) = POP(SP);
  XT_VAL(xt, ATTRIBUTE) = 0;
  PUSH(SP, xt);
}

: find (ca - xt) {
  cell *w = LATEST;
  const char *n = POP(SP);
  while (w) {
    if (EQS(XT_VAL(w, NAME), n)) {
      PUSH(w);
      NEXT;
    }
    w = XT_VAL(w, PREVIOUS);
  }
  THROW(UNDEFINED_WORD);
}

/* Pair */

static pair *fl = NULL;
static pair *spa = NULL;
static cell cur = 0;
#define PAIR_BLOCK_SIZE 1024

: cons (pair x - pair2) {
  pair *p;
  if (fl) {
    p = fl;
    fl = PAIR(fl->cdr);
  } else {
    if (!spa) {
      $call(malloc, PAIR_BLOCK_SIZE * sizeof(fl_pair));
      spa = PAIR(POP(SP));
      cur = 0;
    }
    p = PAIR(&spa[cur++]);
  }
  CADRS(p, POP(SP), TOS);
  TOS_SET(p);
}

: decons (a - ) {
  pair *a = PAIR(POP(SP));
  while (a->cdr) a = PAIR(a->cdr);
  CDRS(a, fl);
  fl = p;
}

/* Stack */

: push (x stack - ) {
  cell stack = POP(SP);
  cell x = POP(SP);
  $call(cons, REF(stack), x);
  REF(stack) = POP(SP);
}

: pop (stack - x) {
  cell stack = POP(SP);
  pair tos = REF(stack);
  if (tos == NULL) {
    THROW(USTACK_UNDERFLOW);
  }
  PUSH(SP, CAR(tos));
  $call(decons, tos);
  REF(stack) = CDR(tos);
}

/* Memory */

: malloc (n - a) {
  TOS_SET(malloc(TOS));
  if (TOS == NULL) {
    ABORT("malloc error");
  }
}

: realloc (s a - a1) {
  R1S(POP(SP));
  TOS_SET(realloc((void *)R1, TOS));
  if (TOS == NULL) {
    ABORT("realloc error");
  }
}

: free (a - ) {
  free(POP(SP));
}

/* Symbol */

: intern (ca - ca1) {
  $call(hash, ca);
  cell h = POP(SP);
  cell i = h % SYMBOL_TABLE_LENGTH;
  pair *p = symbol_table[i];
  const char *s = NULL;
  pair *lastp = NULL;
  const char *ca = CA(POP(SP));
  if (p) {
    while (p) {
      if (EQS(CAR(p), ca)) {
        PUSH(SP, CAR(p));
      }
      p = PAIR(CDR(p));
    }
    lastp = symbol_table[i];
  }
  char c;
  s = CA(HERE);
  while ((c = *ca++)) {
    COMPILEC(c);
    count++;
  }
  $call(padding, HERE);
  HERE_SET(POP(SP));
  NEW(pair, b);
  CADRS(b, s, lastp);
  symbol_table[i] = b;
  PUSH(SP, s);
}

/* Util */

: hash (ca - n) {
  char *key = CA(TOS);
  cell hv = 0;
  unsigned char c;
  while ((c = *key++)) {
    hv = (hv << 5) - hv + c;
  }
  TOS_SET(hv);
}

: padding (ca - ca1) {
  char *d = CA(ALIGNMENT(TOS));
  while (s++ == d) *s = '\0';
  TOS_SET(d);
}

/* IO */

#define BUFFER_LENGTH(x) ((x)->buffer.end - (x)->buffer.start)
#define BUFFER_OVERFLOW(x) ((x)->buffer.current >= (x)->buffer.end)
#define BUFFER_OFFSET(x) ((x)->buffer.current - (x)->buffer.start)

static char dib[FL_INPUT_FILE_BUFFER_SIZE];
extern fl_input fl_stdin = {
  FL_IO_FILE,
  { dib, dib, &dib[FL_INPUT_FILE_BUFFER_SIZE] },
  { { 1 } }
};

static char dob[FL_OUTPUT_FILE_BUFFER_SIZE];
extern fl_output fl_stdout = {
  FL_IO_FILE,
  { dob, dob, &dob[FL_OUTPUT_FILE_BUFFER_SIZE] },
  { { 0 } }
};

fl_input *fl_input_new(fl_io_type type, fl_cell size)
{
  fl_input *i = fl_malloc(sizeof(fl_input));
  i->type = type;
  i->buffer.start = CA(fl_malloc(size));
  i->buffer.current = i->buffer.start;
  i->buffer.end = CA(EXP(i->buffer.start, +, size));
  if (type == FL_IO_FILE) {
    i->buffer.current = i->buffer.end;
  }
  return i;
}

fl_input *fl_string2input(const char *s, fl_cell l)
{
  fl_input *i = fl_malloc(sizeof(fl_input));
  i->type = FL_IO_STRING;
  i->buffer.start = (char *)s;
  i->buffer.current = i->buffer.start;
  i->buffer.end = CA(EXP(i->buffer.start, +, l));
  return i;
}

void fl_input_free(fl_input *i)
{
  if (i->type == FL_IO_FILE) {
    close(i->file.fd);
  }
  fl_free(i->buffer.start);
  fl_free(i);
}

char fl_input_char(fl_input *i)
{
  if (BUFFER_OVERFLOW(i)) {
    switch (i->type) {
    case FL_IO_STRING:
      THROW(EOP);
    case FL_IO_FILE: {
      int n = read(i->file.fd, i->buffer.start, BUFFER_LENGTH(i));
      if (n < 1) {
        THROW(EOP);
      }
      i->buffer.current = i->buffer.start;
      i->buffer.end = CA(i->buffer.start + n);
      break;
    }
    }
  }
  return *i->buffer.current++;
}

void fl_output_char(fl_output *p, char c)
{
  if (BUFFER_OVERFLOW(p)) {
    switch (p->type) {
    case FL_IO_STRING: {
      fl_cell i = BUFFER_OFFSET(p);
      fl_cell l = FL_OUTPUT_BUFFER_EXTEND_SIZE * BUFFER_LENGTH(p);
      p->buffer.start = CA(fl_realloc((void *)p->buffer.start, l));
      p->buffer.current = p->buffer.start + i;
      p->buffer.end = p->buffer.start + l;
      break;
    }
    case FL_IO_FILE:
      write(p->file.fd, p->buffer.start, p->buffer.current - p->buffer.start);
      p->buffer.current = p->buffer.start;
      break;
    }
  }
  *p->buffer.current++ = c;
}

void fl_output_string(fl_output *p, const char *ca)
{
  char c;
  while ((c = *ca++)) {
    fl_output_char(p, c);
  }
}

void fl_flush(fl_output *p)
{
  if (p->type == FL_IO_FILE) {
    write();
  }
}

char dot_buffer1[50];
#define O (fl_output *)CAR(E->output_stack)

: # (c - ) {
  sprintf(dot_buffer1, "%d ", (int)POP(SP));
  fl_output_string(O, dot_buffer1);
}

: #c (c - ) {
  fl_output_char(O, POP(SP));
}

: #d (c - ) {
  sprintf(dot_buffer1, "%d", (int)POP(SP));
  fl_output_string(O, dot_buffer1);
}

: #h (c - ) {
  sprintf(dot_buffer1, "%x ", (int)POP(SP));
  fl_output_string(O, dot_buffer1);
}

: #cr (-) {
  fl_output_char(O, '\n');
}

: #space (-) {
  fl_output_char(O, ' ');
}

: #tab (-) {
  fl_output_char(O, '\t');
}

/* interpreter */

fl_interpreter *fl_interpreter_new(fl_input *src)
{
  NEW(fl_interpreter, i);
  i->into = i->tib;
  i->src = src;
  i->state = FALSE;
  return i;
}

#define CASE_WS case ' ': case '\n': case '\t': case '\0'

void fl_skipws()
{
  fl_input *i = interpreter->src;
  for (;;) {
    switch (fl_input_char(i)) {
    CASE_WS:
      continue;
    default:
      i->buffer.current--;
      return;
    }
  }
}

#define TIB_RSIZE(i) (FL_TIB_SIZE - (i->into - i->tib))
const char *fl_parse_word()
{
  fl_interpreter *i = interpreter;
  fl_input *input = i->src;
  char *d = i->into;
  fl_cell l = TIB_RSIZE(i);
  fl_skipws();
  while (l--) {
    char c = fl_input_char(input);
    switch (c) {
    CASE_WS:
      *i->into++ = '\0';
      return d;
    default:
      *i->into++ = c;
    }
  }
  return d;
}

#define IS_NUMBER(x) (('0' <= x) && (x <= '9'))
#define IS_ALPHA(x) ((('a' <= x) && (x <= 'z')) || (('A' <= x) && (x <= 'Z')))
#define STQ(x)\
  char c;\
  while ((c = *s++))\
    if (!x(c))\
      return FALSE;\
  return TRUE;

fl_cell fl_numberq(const char *s)
{ STQ(IS_NUMBER) }
fl_cell fl_alphaq(const char *s)
{ STQ(IS_ALPHA) }

#define TIB_RSIZE(i) (FL_TIB_SIZE - (i->into - i->tib))
#define EXEC(x) \
  fl_cell _ia[1];\
  _ia[0] = CELL(x);\
  _ia[1] = fl_code("bye");\
  e->ip = _ia;\
  fl_exec(e)

void fl_compile(fl_engine *e, fl_entry *entry)
{
  if ((entry->attribute & FL_IMMEDIATE_BIT) || !interpreter->state) {
    if (entry->attribute & FL_PRIMITIVE_BIT) {
      EXEC(*entry->xt);
    } else if (entry->attribute & FL_CONSTANT_BIT) {
      fl_push(e, CELL(entry->xt[1]));
    } else {
      fl_cell xt[] = {fl_code("bye")};
      fl_rpush(e, CELL(xt));
      e->ip = entry->xt;
      fl_exec(e);
    }
  } else {
    fl_compile_comma(entry);
  }
}

void fl_compile_comma(fl_entry *entry)
{
  if (entry->attribute & FL_PRIMITIVE_BIT) {
    COMPILE(*entry->xt);
  } else if (entry->attribute & FL_CONSTANT_BIT) {
    COMPILE(fl_code("dolit"));
    COMPILE(*entry->xt);
  } else {
    COMPILE(fl_code("call"));
    COMPILE(entry->xt);
  }
}

void fl_interpret(fl_interpreter *i, fl_engine *e)
{
  interpreter = i;
  for (;;) {
    const char* w = fl_parse_word();
    if (EQS(w, "bye")) return;
    fl_entry *entry = fl_find(w);
    if (entry) {
      fl_compile(e, entry);
    } else {
      if (fl_numberq(w)) {
        fl_cell n = atoi(w);
        if (i->state) {
          COMPILE(fl_code("dolit"));
          COMPILE(n);
        } else
          fl_push(e, n);
      } else {
        fl_pop(e);
        THROW(UNDEFINED_WORD);
      }
    }
    i->into = i->tib;
  }
}

